home *** CD-ROM | disk | FTP | other *** search
/ HPAVC / HPAVC CD-ROM.iso / STARS3D.ZIP / STARS.PAS < prev   
Pascal/Delphi Source File  |  1995-12-22  |  4KB  |  146 lines
  1. Uses Crt,Mcga;
  2. {$I C:\Pas\Fonts.Fnt}
  3. Type
  4.     Star = Record
  5.          X,
  6.          Y,
  7.          Z : Integer;
  8. end;
  9.  
  10.  
  11. Var
  12.    Stars : Array[1..300] Of Star;
  13.    X,Y,Loop,XX,YY,Ypos,Ypos1 : Word;
  14.    Pos : Array[1..300] Of Star;
  15.    Direction : Word;
  16.    Time : LongInt;
  17.  
  18. Procedure Setup;
  19. Begin
  20.      Direction := 1;
  21.      For Loop := 1 To 300 Do
  22.      Begin
  23.           Stars[Loop].X := Random(320)-160;
  24.           Stars[Loop].Y := Random(200)-100;
  25.           Stars[Loop].Z := Loop;
  26.      end;
  27. end;
  28.  
  29. Procedure Calc;
  30. Begin
  31.      For Loop := 1 To 300 Do
  32.      Begin
  33.           Pos[Loop].X := Stars[Loop].X * 100 Div Stars[Loop].Z+160;
  34.           Pos[Loop].Y := Stars[Loop].Y * 100 Div Stars[Loop].Z+100;
  35.      end;
  36. end;
  37.  
  38. Procedure MoveStars;
  39. Begin
  40.      For Loop := 1 To 300 Do
  41.      Begin
  42.           Dec(Stars[Loop].Z,4);
  43.           If Stars[Loop].Z < 1 Then Inc(Stars[Loop].Z,Loop+4);
  44.      end;
  45. end;
  46.  
  47. Procedure Border;
  48. Var Loop,Loop1,Col : Word;
  49. Begin
  50.          For Loop := 1 To 319 Do
  51.          PutPixel(Loop,Ypos,100,VirAddr);
  52.  
  53.          For Loop := 1 To 319 Do
  54.          PutPixel(Loop,Ypos1,100,VirAddr);
  55.  
  56.          {Slow But Not As Slow As Last Time - Just Draws A Line}
  57.          Flip;
  58.  
  59. end;
  60.  
  61. Procedure Logo;
  62. Begin
  63.      {Sloppy But Hey It Works}
  64.  
  65.      Inc(Time);
  66.      If Time < 63 Then SetPal(1,0,0,Time);
  67.      If Time < 63 Then PutMsg(78,70,'A STARFIELD');
  68.      If Time = 63 Then SetPal(1,0,0,0);
  69.      If (Time > 63) And (Time <126) Then PutMsg(78,138,'BY');
  70.      If (Time > 63) And (Time < 126) Then SetPal(1,0,0,Time-62);
  71.      If (Time > 126) And (Time <180) Then SetPal(1,0,0,Time-125);
  72.      If (Time > 126) And (Time <280) Then PutMsg(78,64,'THE DARKMAN');
  73. end;
  74.  
  75.  
  76. Procedure DrawStars;
  77. Begin
  78.      For Loop := 1 To 300 Do
  79.      Begin
  80.           X := Pos[Loop].X;
  81.           Y := Pos[Loop].Y;
  82.  
  83.           If (X>1) And (X<320) And (Y>1) And (Y<Ypos1) And (Y>Ypos) Then Begin
  84.           If Pos[Loop].X <1 Then Inc(Pos[Loop].X,160);
  85.           If Pos[Loop].X > 320 Then Dec(Pos[Loop].X,160);
  86.           If Pos[Loop].Y <1 Then Inc(Pos[Loop].Y,100);
  87.           If Pos[Loop].Y >200 Then Dec(Pos[Loop].Y,100);
  88.  
  89.           If Stars[Loop].Z > 400 Then PutPixel(X,Y,1,VirAddr) else
  90.           If Stars[Loop].Z > 300 Then PutPixel(X,Y,2,VirAddr) else
  91.           If Stars[Loop].Z > 200 Then PutPixel(X,Y,3,VirAddr) else
  92.           If Stars[Loop].Z > 100 Then PutPixel(X,Y,4,VirAddr) else
  93.           PutPixel(X,Y,5,VirAddr);
  94.      end;
  95. end;
  96.      {Flip;}
  97. end;
  98.  
  99. Begin
  100.      Ypos := 100; Ypos1 := 100;
  101.      ClrScr;
  102.      Writeln('Darius Sutherland / The Darkman Presents A 3D StarField With Various Affects');
  103.      Writeln('Main Coder - Darius The Darkman Sutherland');
  104.      Writeln('GFX        - Darius The Darkman Sutherland');
  105.      Writeln('Sound      - N/A');
  106.      Writeln;
  107.      Writeln('Old Versin      10 12.95');
  108.      Writeln('Updated Version 22.12.95');
  109.      Readkey;
  110.  
  111.      Gmode;
  112.      setpal(100,40,50,60);
  113.      {SetPal(1,5,5,15);} SetPal(2,10,10,20);
  114.      SetPal(3,20,20,30); SetPal(4,30,30,50);
  115.      SetPal(5,50,50,60);
  116.      SetPal(1,0,0,0);
  117.  
  118.      Border;
  119.      Delay(700);
  120.  
  121.      Setup;
  122.      DrawStars;
  123.      Calc;
  124.      REPEAT
  125.      Calc;
  126.      If Time < 280 Then Logo;
  127.      DrawStars;
  128.      MoveStars;
  129.      If Ypos > 10 Then Dec(Ypos,6);
  130.      If Ypos1 < 190 Then Inc(Ypos1,6);
  131.      Border;
  132.      Clscr(0);
  133.      UNTIL KeyPressed;
  134.      Tmode;
  135.      Writeln('Greetz Go To : ');
  136.      Writeln;
  137.      Writeln('Mathew Nemesis Thomas');
  138.      Writeln('Grant Smith / Denthor');
  139.      Writeln('Alex Evans / Statix');
  140.      Writeln;
  141.      Writeln('Fonts Drawn By Darius Sutherland Using Fonted Beta Version By Him');
  142.      Writeln('Fonted Should Be Available On Ftp.Cdrom.Com /Pub/Demos/Incoming');
  143. end.
  144.  
  145.  
  146.